home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / icon_utl / exicon / exticons.frm < prev    next >
Text File  |  1994-03-22  |  13KB  |  493 lines
  1. VERSION 2.00
  2. Begin Form extIcons 
  3.    BackColor       =   &H00C0C0C0&
  4.    Caption         =   "Icon Extractor"
  5.    ClientHeight    =   7380
  6.    ClientLeft      =   1095
  7.    ClientTop       =   1485
  8.    ClientWidth     =   7800
  9.    FontBold        =   0   'False
  10.    FontItalic      =   0   'False
  11.    FontName        =   "Fixedsys"
  12.    FontSize        =   9
  13.    FontStrikethru  =   0   'False
  14.    FontUnderline   =   0   'False
  15.    Height          =   7785
  16.    Icon            =   EXTICONS.FRX:0000
  17.    Left            =   1035
  18.    LinkTopic       =   "Form1"
  19.    ScaleHeight     =   492
  20.    ScaleMode       =   3  'Pixel
  21.    ScaleWidth      =   520
  22.    Top             =   1140
  23.    Width           =   7920
  24.    Begin CheckBox SrchSubs 
  25.       BackColor       =   &H00C0C0C0&
  26.       Caption         =   "Search &Subdirectories"
  27.       Height          =   255
  28.       Left            =   1920
  29.       TabIndex        =   14
  30.       Top             =   90
  31.       Width           =   2175
  32.    End
  33.    Begin Frame Frame1 
  34.       BackColor       =   &H00C0C0C0&
  35.       Caption         =   "Frame1"
  36.       Height          =   3855
  37.       Left            =   120
  38.       TabIndex        =   7
  39.       Top             =   3360
  40.       Width           =   5055
  41.       Begin DirListBox Dir1 
  42.          Height          =   2280
  43.          Left            =   240
  44.          TabIndex        =   10
  45.          Top             =   1260
  46.          Width           =   2055
  47.       End
  48.       Begin FileListBox File1 
  49.          Height          =   2955
  50.          Left            =   2640
  51.          TabIndex        =   9
  52.          Top             =   600
  53.          Width           =   2175
  54.       End
  55.       Begin DriveListBox Drive1 
  56.          Height          =   315
  57.          Left            =   240
  58.          TabIndex        =   8
  59.          Top             =   600
  60.          Width           =   2055
  61.       End
  62.       Begin Label Label5 
  63.          BackColor       =   &H00C0C0C0&
  64.          Caption         =   "&Drive"
  65.          Height          =   255
  66.          Left            =   240
  67.          TabIndex        =   13
  68.          Top             =   360
  69.          Width           =   615
  70.       End
  71.       Begin Label Label6 
  72.          BackColor       =   &H00C0C0C0&
  73.          Caption         =   "Di&rectory"
  74.          Height          =   255
  75.          Left            =   240
  76.          TabIndex        =   12
  77.          Top             =   1020
  78.          Width           =   855
  79.       End
  80.       Begin Label Label7 
  81.          BackColor       =   &H00C0C0C0&
  82.          Caption         =   "&File"
  83.          Height          =   255
  84.          Left            =   2640
  85.          TabIndex        =   11
  86.          Top             =   360
  87.          Width           =   375
  88.       End
  89.    End
  90.    Begin CommandButton Command2 
  91.       Caption         =   "E&xit"
  92.       Height          =   285
  93.       Left            =   4560
  94.       TabIndex        =   6
  95.       Top             =   960
  96.       Width           =   1095
  97.    End
  98.    Begin CommandButton Command1 
  99.       Caption         =   "&Go"
  100.       Height          =   285
  101.       Left            =   4560
  102.       TabIndex        =   5
  103.       Top             =   360
  104.       Width           =   1095
  105.    End
  106.    Begin TextBox txtDestDir 
  107.       Height          =   285
  108.       Left            =   240
  109.       TabIndex        =   4
  110.       Text            =   "Text2"
  111.       Top             =   960
  112.       Width           =   3855
  113.    End
  114.    Begin TextBox txtFileName 
  115.       Height          =   285
  116.       Left            =   240
  117.       TabIndex        =   2
  118.       Text            =   "Text1"
  119.       Top             =   360
  120.       Width           =   3855
  121.    End
  122.    Begin Label Label4 
  123.       BackColor       =   &H00C0C0C0&
  124.       Caption         =   "Label4"
  125.       Height          =   255
  126.       Left            =   240
  127.       TabIndex        =   15
  128.       Top             =   1320
  129.       Width           =   5415
  130.    End
  131.    Begin Label Label3 
  132.       AutoSize        =   -1  'True
  133.       BackColor       =   &H00C0C0C0&
  134.       Caption         =   "&Destination Directory:"
  135.       Height          =   195
  136.       Left            =   240
  137.       TabIndex        =   3
  138.       Top             =   720
  139.       Width           =   1860
  140.    End
  141.    Begin Label Label2 
  142.       AutoSize        =   -1  'True
  143.       BackColor       =   &H00C0C0C0&
  144.       Caption         =   "Source &File(s):"
  145.       Height          =   195
  146.       Left            =   240
  147.       TabIndex        =   0
  148.       Top             =   120
  149.       Width           =   1245
  150.    End
  151.    Begin Image Image1 
  152.       Height          =   495
  153.       Left            =   6360
  154.       Top             =   720
  155.       Width           =   495
  156.    End
  157.    Begin Label Label1 
  158.       Alignment       =   2  'Center
  159.       BackColor       =   &H00C0C0C0&
  160.       Caption         =   "Label1"
  161.       Height          =   255
  162.       Left            =   6000
  163.       TabIndex        =   1
  164.       Top             =   360
  165.       Width           =   1215
  166.    End
  167. End
  168. Option Explicit
  169. DefInt A-Z
  170.  
  171. Declare Function ExtractIcon% Lib "shell" (ByVal hInst, ByVal FileName$, ByVal iIcon)
  172. Declare Function DestroyIcon% Lib "user" (ByVal hIcon)
  173. Declare Function DrawIcon% Lib "user" (ByVal hDC%, ByVal x%, ByVal y%, ByVal hIcon%)
  174. Declare Function GetWindowWord% Lib "user" (ByVal hWnd, ByVal nOffset)
  175. Declare Function GetModuleHandle% Lib "kernel" (ByVal ModuleName$)
  176. Declare Function GlobalLock& Lib "kernel" (ByVal hGlobal)
  177. Declare Function GlobalSize& Lib "kernel" (ByVal hGlobal)
  178. Declare Function GlobalUnlock% Lib "kernel" (ByVal hGlobal)
  179. Declare Function GetWindowsDirectory% Lib "kernel" (ByVal WinDirPath$, ByVal lenPath)
  180.  
  181. ' requires Win 3.1 for hmemcpy
  182. Declare Sub hmemcpy Lib "kernel" (ByVal hpDest&, ByVal hpSource&, ByVal cbCopy&)
  183.  
  184. Const GWW_HINSTANCE = -6
  185. Const MB_ICONSTOP = 16
  186. Const MB_YESNO = 4
  187. Const IDYES = 6
  188. Const MINIMIZED = 1
  189. Const HOURGLASS = 11
  190. Const DEFAULT = 0
  191.  
  192. Dim Drive$, Path$, Pattern$, dstDir$
  193.  
  194. Dim xIcon, yIcon
  195.  
  196. Function BaseName$ (fSrc$, fmt$)
  197. '=========================================
  198. Dim p%, n$
  199.  
  200. ' chop off extension
  201. p = InStr(fSrc$, ".")
  202. If p Then
  203.     n$ = Left$(fSrc$, p - 1)
  204. Else
  205.     n$ = fSrc$
  206. End If
  207.  
  208. ' chop off drive letter
  209. p = InStr(n$, ":")
  210. If p Then n$ = Mid$(n$, p + 1)
  211.  
  212. ' chop off path
  213. p = InStr(n$, "\")
  214. Do While p
  215.     n$ = Mid$(n$, p + 1)
  216.     p = InStr(n$, "\")
  217. Loop
  218.  
  219. ' should have base file name of source
  220. While Len(n$) + Len(fmt$) > 8
  221.     n$ = Left(n$, Len(n$) - 1)
  222. Wend
  223.  
  224. While Len(n$) + Len(fmt$) < 8
  225.     n$ = n$ & "0"
  226. Wend
  227.  
  228. BaseName$ = n$
  229. '=========================================
  230. End Function
  231.  
  232. Sub Command1_Click ()
  233. '=========================================================
  234. Dim srcFile$, nl$, msg$, Title$
  235.  
  236. srcFile$ = Trim$(txtFilename)
  237. dstDir$ = Trim$(txtDestDir)
  238. xIcon = 0: yIcon = 120
  239.  
  240. ' make sure destination directory exists
  241.  
  242. On Error GoTo dst_Error
  243. ChDir dstDir$   ' possible error here
  244.  
  245. ChDir App.Path
  246. Cls
  247.  
  248. If Len(dstDir$) > 0 And Right$(dstDir$, 1) <> "\" Then
  249.     dstDir$ = dstDir$ & "\"
  250. End If
  251.  
  252. ParsePath
  253.  
  254. MousePointer = HOURGLASS
  255. SearchSubdirectories 0
  256. MousePointer = DEFAULT
  257. MsgBox "Done!"
  258. Exit Sub
  259.  
  260. '=========================================================
  261. dst_Error:
  262. nl$ = Chr$(13) & Chr$(10)
  263.  
  264. Select Case Err
  265.     Case 76     ' path not found
  266.         msg$ = "Create the destination directory:" & nl$
  267.         msg$ = msg$ & dstDir$
  268.         Title$ = "!! Error - Destination directory does not exist. !!"
  269.         If MsgBox(msg$, MB_ICONSTOP + MB_YESNO, Title$) = IDYES Then
  270.             MkDir dstDir$
  271.             Resume Next
  272.         Else
  273.             End
  274.         End If
  275.  
  276.     Case Else
  277.  
  278.         msg$ = "Error " & Format$(Err) & nl$ & nl$
  279.         msg$ = msg$ & Error$ & nl$ & nl$
  280.         msg$ = msg$ & "has occurred."
  281.         MsgBox msg$, MB_ICONSTOP, "!! Error !!"
  282.         End
  283.  
  284. End Select
  285. '=========================================================
  286. End Sub
  287.  
  288. Sub Command2_Click ()
  289.     End
  290. End Sub
  291.  
  292. Sub CopyIconsFromFile (i As Image, fSrc$)
  293. '===============================================================
  294. Dim hInst, hIcon, IconsInFile, currIcon, destFile$, dstIcon
  295. Dim z, iName$, fmt$, IconFile$
  296.  
  297. hInst = GetWindowWord(Me.hWnd, GWW_HINSTANCE)
  298. IconsInFile = ExtractIcon(hInst, fSrc$, -1)
  299.  
  300. If IconsInFile = 0 Then Exit Sub
  301.  
  302. ' get base file name for extracted icons
  303. fmt$ = String$(Len(Format(IconsInFile)), "0")
  304. iName$ = BaseName$(fSrc$, fmt$)
  305.  
  306. ' the image control must have a DragIcon to start
  307. i.DragIcon = Me.Icon
  308.  
  309. currIcon = 0
  310.  
  311. Do While currIcon < IconsInFile
  312.     IconFile$ = iName$ & Format$(currIcon + 1, fmt$) & ".ico"
  313.     Label1 = IconFile$
  314.     destFile$ = dstDir$ & IconFile$
  315.     hIcon = ExtractIcon(hInst, fSrc$, currIcon)
  316.     If xIcon + 36 > ScaleWidth Then xIcon = 0: yIcon = yIcon + 40
  317.     If yIcon + 36 > ScaleHeight Then yIcon = 120
  318.     Me.Line (xIcon, yIcon)-(xIcon + 40, yIcon + 40), Me.BackColor, BF
  319.     z = DrawIcon%(hDC, xIcon + 4, yIcon + 4, hIcon)
  320.     xIcon = xIcon + 40
  321.     dstIcon = i.DragIcon
  322.     vbCopyIcon hIcon, dstIcon
  323.     i.Picture = i.DragIcon
  324.     DoEvents
  325.     If WindowState = MINIMIZED Then
  326.         Caption = IconFile$
  327.         Me.Refresh
  328.     Else
  329.         i.Refresh
  330.     End If
  331.     SavePicture i.DragIcon, destFile$
  332.     currIcon = currIcon + 1
  333.     z = DestroyIcon(hIcon)
  334. Loop
  335. '===============================================================
  336. End Sub
  337.  
  338. Sub Form_Load ()
  339. '=====================================================
  340. Dim pl%, WinDir$
  341.  
  342. Frame1.Visible = False
  343.  
  344. Me.Left = (Screen.Width - Me.Width) \ 2
  345. Me.Top = (Screen.Height - Me.Height) \ 2
  346.  
  347. WinDir$ = Space$(256)
  348. pl = GetWindowsDirectory%(WinDir$, 256)
  349.  
  350. ' set a couple of default values
  351. txtFilename = Left(WinDir$, pl) & "\moricons.dll"
  352. txtDestDir = "c:\icons"
  353.  
  354. Label1 = ""
  355. Label4 = "Directory being searched"
  356. '=====================================================
  357. End Sub
  358.  
  359. Sub Form_Resize ()
  360.     If WindowState <> MINIMIZED Then Caption = "Icon Extractor"
  361. End Sub
  362.  
  363. Sub ParsePath ()
  364. '===================================================
  365. Dim t$, r%, lr%
  366.  
  367. txtFilename = Trim$(txtFilename)
  368. t$ = txtFilename
  369. If InStr(t$, ":") = 2 Then
  370.     Drive1.Drive = Left$(t$, 1)
  371. Else
  372.     Drive1.Drive = Left$(CurDir$, 1)
  373. End If
  374.  
  375. r = InStr(t$, "\")
  376. Do Until r = 0
  377.     lr = r
  378.     r = InStr(lr + 1, t$, "\")
  379. Loop
  380.  
  381. Path$ = Left$(t$, lr - 1)
  382. If Right$(Path$, 1) = ":" Then Path$ = Path$ & "\"
  383. Pattern$ = Mid$(t$, lr + 1)
  384.  
  385. Dir1.Path = Path$
  386. File1.Path = Path$
  387. File1.Pattern = Pattern$
  388. '===================================================
  389. End Sub
  390.  
  391. Sub SearchCurrDir ()
  392. '==========================================================
  393. Dim subDir$, fc, cf$, hInst
  394.  
  395. If File1.ListCount = 0 Then Exit Sub
  396.  
  397. subDir$ = Dir1.Path
  398. Label4 = subDir$
  399. Label4.Refresh
  400.  
  401. If Right$(subDir$, 1) <> "\" Then subDir$ = subDir$ + "\"
  402.  
  403. fc = 0
  404. Do While fc < File1.ListCount
  405.     If Len(File1.List(fc)) > 3 Then
  406.         ' don't extract icons from icon files
  407.         If UCase$(Right$(File1.List(fc), 4)) <> ".ICO" Then
  408.             cf$ = subDir$ + File1.List(fc)
  409.             CopyIconsFromFile Me.Image1, cf$
  410.         End If
  411.     End If
  412.     fc = fc + 1
  413. Loop
  414. '==========================================================
  415. End Sub
  416.  
  417. Sub SearchSubdirectories (depth)
  418. '==========================================================
  419. Dim sd, sdMax
  420. sd = -1
  421.  
  422. If SrchSubs Then
  423.     sdMax = Dir1.ListCount
  424. Else
  425.     sdMax = 0
  426. End If
  427.  
  428. Do While sd < sdMax
  429.     If sd = -1 Then
  430.         SearchCurrDir
  431.     Else
  432.         Dir1.Path = Dir1.List(sd)
  433.         File1.Path = Dir1.Path
  434.         SearchSubdirectories depth + 1
  435.     End If
  436.     sd = sd + 1
  437.     DoEvents
  438. Loop
  439. If depth > 0 And sd > -1 Then Dir1.Path = Dir1.List(-2)
  440. '==========================================================
  441. End Sub
  442.  
  443. Sub txtFileName_KeyPress (KeyAscii As Integer)
  444. '==================================================================
  445. 'If KeyAscii = 13 Then
  446. '    If InStr(txtFilename, "*") Or InStr(txtFilename, "?") Then
  447. '        File1.Pattern = LTrim$(RTrim$(txtFilename))
  448. '        fMany% = True
  449. '    Else
  450. '        fMany% = False
  451. '    End If: KeyAscii = 0
  452. 'End If
  453. '==================================================================
  454.  
  455. End Sub
  456.  
  457. Sub vbCopyIcon (hSource, hDest)
  458. '==========================================================
  459. ' Copies the icon from *hSource to *hDest, provided the
  460. ' memory blocks at *hSource and *hDest are the same size.
  461. ' hSource and hDest are Handles to Icons
  462. ' eg. hDest   = Control.DragIcon
  463. '     hSource = ExtractIcon(hInst, SourceFile$, nIcon)
  464.  
  465. Dim sizeSource&, sizeDest&, fpSource&, fpDest&, x, msg$
  466.  
  467. ' get size of memory blocks
  468. sizeSource& = GlobalSize&(hSource)
  469. sizeDest& = GlobalSize&(hDest)
  470.  
  471. If sizeDest& <> sizeSource& Then
  472.     If sizeSource& <> 288 Then  ' not a monochrome icon
  473.         msg$ = "Source size = " & Format$(sizeSource&) & Chr$(13) & Chr$(10)
  474.         msg$ = msg$ & "Destination size = " & Format$(sizeDest&)
  475.         MsgBox msg$, MB_ICONSTOP, "!! In vbCopyIcon !!"
  476.     End If
  477.     Exit Sub
  478. End If
  479.  
  480. ' lock memory and get far pointers to Source & Destination
  481. fpSource& = GlobalLock&(hSource)
  482. fpDest& = GlobalLock&(hDest)
  483.  
  484. ' copy Source to Destination
  485. hmemcpy fpDest&, fpSource&, sizeSource&
  486.  
  487. ' unlock memory
  488. x = GlobalUnlock(hDest)
  489. x = GlobalUnlock(hSource)
  490. '==========================================================
  491. End Sub
  492.  
  493.